home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / a-ngcoty.adb < prev    next >
Text File  |  1994-05-19  |  14KB  |  534 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --   A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S    --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.3 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Ada.Numerics.Aux; use Ada.Numerics.Aux;
  26. package body Ada.Numerics.Generic_Complex_Types is
  27.  
  28.    subtype R is Real'Base;
  29.  
  30.    ---------
  31.    -- "+" --
  32.    ---------
  33.  
  34.    function "+" (Right : Complex) return Complex is
  35.    begin
  36.       return Right;
  37.    end "+";
  38.  
  39.    function "+" (Left, Right : Complex) return Complex is
  40.    begin
  41.       return Complex'(Left.Re + Right.Re, Left.Im + Right.Im);
  42.    end "+";
  43.  
  44.    function "+" (Right : Imaginary) return Imaginary is
  45.    begin
  46.       return Right;
  47.    end "+";
  48.  
  49.    function "+" (Left, Right : Imaginary) return Imaginary is
  50.    begin
  51.       return Imaginary (R (Left) + R (Right));
  52.    end "+";
  53.  
  54.    function "+" (Left : Complex; Right : Real'Base) return Complex is
  55.    begin
  56.       return Complex'(Left.Re + Right, Left.Im);
  57.    end "+";
  58.  
  59.    function "+" (Left : Real'Base; Right : Complex) return Complex is
  60.    begin
  61.       return Complex'(Left + Right.Re, Right.Im);
  62.    end "+";
  63.  
  64.    function "+" (Left : Complex; Right : Imaginary) return Complex is
  65.    begin
  66.       return Complex'(Left.Re, Left.Im + R (Right));
  67.    end "+";
  68.  
  69.    function "+" (Left : Imaginary; Right : Complex) return Complex is
  70.    begin
  71.       return Complex'(R (Left) + Right.Re, Right.Im);
  72.    end "+";
  73.  
  74.    function "+" (Left : Imaginary; Right : Real'Base) return Complex is
  75.    begin
  76.       return Complex'(Right, R (Left));
  77.    end "+";
  78.  
  79.    function "+" (Left : Real'Base; Right : Imaginary) return Complex is
  80.    begin
  81.       return Complex'(Left, R (Right));
  82.    end "+";
  83.  
  84.    ---------
  85.    -- "-" --
  86.    ---------
  87.  
  88.    function "-" (Right : Complex) return Complex is
  89.    begin
  90.       return (-Right.Re, -Right.Im);
  91.    end "-";
  92.  
  93.    function "-" (Left, Right : Complex) return Complex is
  94.    begin
  95.       return (Left.Re - Right.Re, Left.Im - Right.Im);
  96.    end "-";
  97.  
  98.    function "-" (Right : Imaginary) return Imaginary is
  99.    begin
  100.       return Imaginary (-R (Right));
  101.    end "-";
  102.  
  103.    function "-" (Left, Right : Imaginary) return Imaginary is
  104.    begin
  105.       return Imaginary (R (Left) - R (Right));
  106.    end "-";
  107.  
  108.    function "-" (Left : Complex; Right : Real'Base) return Complex is
  109.    begin
  110.       return Complex'(Left.Re - Right, Left.Im);
  111.    end "-";
  112.  
  113.    function "-" (Left : Real'Base; Right : Complex) return Complex is
  114.    begin
  115.       return Complex'(Left - Right.Re, -Right.Im);
  116.    end "-";
  117.  
  118.    function "-" (Left : Complex; Right : Imaginary) return Complex is
  119.    begin
  120.       return Complex'(Left.Re, Left.Im - R (Right));
  121.    end "-";
  122.  
  123.    function "-" (Left : Imaginary; Right : Complex) return Complex is
  124.    begin
  125.       return Complex'(R (Left) - Right.Re, -Right.Im);
  126.    end "-";
  127.  
  128.    function "-" (Left : Imaginary; Right : Real'Base) return Complex is
  129.    begin
  130.       return Complex'(-Right, R (Left));
  131.    end "-";
  132.  
  133.    function "-" (Left : Real'Base; Right : Imaginary) return Complex is
  134.    begin
  135.       return Complex'(Left, -R (Right));
  136.    end "-";
  137.  
  138.    ---------
  139.    -- "*" --
  140.    ---------
  141.  
  142.    function "*" (Left, Right : Complex) return Complex is
  143.    begin
  144.       return  (Re => Left.Re * Right.Re - Left.Im * Right.Im,
  145.                Im => Left.Re * Right.Im + Left.Im * Right.Re);
  146.    end "*";
  147.  
  148.    function "*" (Left, Right : Imaginary) return Real'Base is
  149.    begin
  150.       return -R (Left) * R (Right);
  151.    end "*";
  152.  
  153.    function "*" (Left : Complex; Right : Real'Base) return Complex is
  154.    begin
  155.       return Complex'(Left.Re * Right, Left.Im * Right);
  156.    end "*";
  157.  
  158.    function "*" (Left : Real'Base; Right : Complex) return Complex is
  159.    begin
  160.       return (Left * Right.Re, Left * Right.Im);
  161.    end "*";
  162.  
  163.    function "*" (Left : Complex; Right : Imaginary) return Complex is
  164.    begin
  165.       return Complex'(-(Left.Im * R (Right)), Left.Re * R (Right));
  166.    end "*";
  167.  
  168.    function "*" (Left : Imaginary; Right : Complex) return Complex is
  169.    begin
  170.       return Complex'(-(R (Left) * Right.Im), R (Left) * Right.Re);
  171.    end "*";
  172.  
  173.    function "*" (Left : Imaginary; Right : Real'Base) return Imaginary is
  174.    begin
  175.       return Left * Imaginary (Right);
  176.    end "*";
  177.  
  178.    function "*" (Left : Real'Base; Right : Imaginary) return Imaginary is
  179.    begin
  180.       return Imaginary (Left * R (Right));
  181.    end "*";
  182.  
  183.    ---------
  184.    -- "/" --
  185.    ---------
  186.  
  187.    function "/" (Left, Right : Complex) return Complex is
  188.       a : constant R := Left.Re;
  189.       b : constant R := Left.Im;
  190.       c : constant R := Right.Re;
  191.       d : constant R := Right.Im;
  192.  
  193.    begin
  194.       return Complex'(Re => ((a * c) + (b * d)) / (c ** 2 + d ** 2),
  195.                       Im => ((b * c) - (a * d)) / (c ** 2 + d ** 2));
  196.    end "/";
  197.  
  198.    function "/" (Left, Right : Imaginary) return Real'Base is
  199.    begin
  200.       return R (Left) / R (Right);
  201.    end "/";
  202.  
  203.    function "/" (Left : Complex; Right : Real'Base) return Complex is
  204.    begin
  205.       return Complex'(Left.Re / Right, Left.Im / Right);
  206.    end "/";
  207.  
  208.    function "/" (Left : Real'Base; Right : Complex) return Complex is
  209.       a : constant R := Left;
  210.       c : constant R := Right.Re;
  211.       d : constant R := Right.Im;
  212.    begin
  213.       return Complex'(Re =>  (a * c) / (c ** 2 + d ** 2),
  214.                       Im => -(a * d) / (c ** 2 + d ** 2));
  215.    end "/";
  216.  
  217.    function "/" (Left : Complex; Right : Imaginary) return Complex is
  218.       a : constant R := Left.Re;
  219.       b : constant R := Left.Im;
  220.       d : constant R := R (Right);
  221.  
  222.    begin
  223.       return (b / d,  -a / d);
  224.    end "/";
  225.  
  226.    function "/" (Left : Imaginary; Right : Complex) return Complex is
  227.       b : constant R := R (Left);
  228.       c : constant R := Right.Re;
  229.       d : constant R := Right.Im;
  230.  
  231.    begin
  232.       return (Re => -b * d / (c ** 2 + d ** 2),
  233.               Im => b * c / (c ** 2 + d ** 2));
  234.    end "/";
  235.  
  236.    function "/" (Left : Imaginary; Right : Real'Base) return Imaginary is
  237.    begin
  238.       return Imaginary (R (Left) / Right);
  239.    end "/";
  240.  
  241.    function "/" (Left : Real'Base; Right : Imaginary) return Imaginary is
  242.    begin
  243.       return Imaginary (-Left / R (Right));
  244.    end "/";
  245.  
  246.    ----------
  247.    -- "**" --
  248.    ----------
  249.  
  250.    function "**" (Left : Complex; Right : Integer) return Complex is
  251.       Result : Complex := (1.0, 0.0);
  252.       Factor : Complex := Left;
  253.       Exp    : Natural := Right;
  254.  
  255.    begin
  256.       --  We use the standard logarithmic approach, Exp gets shifted right
  257.       --  testing successive low order bits and Factor is the value of the
  258.       --  base raised to the next power of 2. For positive exponents we
  259.       --  multiply the result by this factor, for negative expo